import Array
import Data.List
import Debug.Trace
import System.IO
import System.Console.ANSI


{- --------------------------- Datove struktury ----------------------------- -}
{- -------------------------------------------------------------------------- -}
{- -------------------------------------------------------------------------- -}

{- Datovy typ pro hrace a jeho symbol na hracim poli -}
data Player = Cross | Circle | None deriving Eq

{- Alias pro hraci pole - matici polozek typu Player -}
type GameFieldArray = Array (Int,Int) Player

{- Border ohranicuje misto v game fieldu, kde se "neco deje" viz GameField. -}
data GameFieldBorder = GameFieldBorder { left, right, top, bottom ::Int } deriving Show

{- Hraci plan se sklada z 
	fieldData - matice se symboly hracu, nebo praznym symbolem
		- fieldData by mely byt meneny pres pristupovou fci, protoze jejich zmena
		vyzaduje i zmenu hranic.
	border - hranice, ktere oznacuji ctverec, ve kterem se hra odehrava -}
data GameField = GameField { fieldData::GameFieldArray, border::GameFieldBorder, symbolsCount::Int }


switchPlayer :: Player -> Player
switchPlayer player = 
	case player of
		Cross -> Circle
		Circle -> Cross
		None -> error "None player nemuze byt 'switched'."

createGameField :: Int -> Int -> GameField
createGameField width height = 
	if (width < 5) || (height < 5) then error "Pole mensi jak 5x5 nedava smysl"
	else
		let widthHalf = (width `div` 2) in
		let heightHalf = (height `div` 2) in
		GameField (listArray ((1,1),(width, height)) [None | x<-[1..width], y<-[1..height]])
			(GameFieldBorder (widthHalf - 1) (widthHalf + 1) (heightHalf - 1) (heightHalf + 1))
			0	-- inicializacni pocet symbolu
					
width gameField = let (width, height) = size gameField in width
height gameField = let (width, height) = size gameField in height
size gameField = let ((_,_), result) = bounds (fieldData gameField) in result

isFull :: GameField -> Bool
isFull field = (symbolsCount field) == (width field * height field)

isEmpty :: GameField -> Bool
isEmpty field = (symbolsCount field) == 0

isValidIndex :: (Int, Int) -> GameField -> Bool
isValidIndex (x,y) gameField = 
	let (width, height) = size gameField in
	x >= 1 && x <= width && y >= 1 && y <= height
			
get :: (Int, Int) -> GameField -> Player
get (x,y) f = (fieldData f)!(x,y)
			
push :: (Int, Int) -> Player -> GameField -> GameField
push (x,y) player orig = 
	GameField (fieldData orig // [((x,y),player)]) (newBorder (x,y) (border orig)) ((symbolsCount orig)+1)
	where 
		newBorder (x,y) border = 
			let (newTop, newBottom) = newVerticalBorder y (top border) (bottom border) in
			let (newLeft, newRight) = newHorizontalBorder x (left border) (right border) in
			GameFieldBorder newLeft newRight newTop newBottom
		
		newHorizontalBorder x left right = 
			if x < left then (x, right)
			else if x > right then (left, x)
			else (left, right)
			
		newVerticalBorder y top bottom = 
			if y < top then (y, bottom)
			else if y > bottom then (top, y)
			else (top, bottom)

{- pomocna konstanta se seznamem vsech smeru jako 2D souradnice (x,y) -}
allDirections = foldl (\result (d1,d2) -> result++[d1,d2]) [] allDirectionsInZip
{- konstant se seznamem dvojis smeru, ve dvojici jsou vzdy dva opacne smery -}
allDirectionsInZip = [((-1,0), (1,0)), ((1,1), (-1,-1)), ((0,1),(0,-1)), ((1,-1), (-1,1))]

moveInDirection :: (Int,Int) -> (Int, Int) -> (Int, Int)
moveInDirection (x,y) (dx,dy) = (x+dx, y+dy)

{- zkontroleje, jestli tah do dane pozice zpusobi konec hry -}
checkEndOfGame ::  (Int, Int) -> Player -> GameField -> Bool
checkEndOfGame index player field = 
	if (get index field) == player then
		any (\n -> n >= 4) $ 
		map (\(dir1, dir2) -> checkEnd dir1 dir2) allDirectionsInZip
	else
		False
	where
		checkEnd direction1 direction2 = 
			checkEnd' index 0 direction1 +
			checkEnd' index 0 direction2
		checkEnd' _ 4 _ = 4
		checkEnd' index count direction =
			let nextIndex = (moveInDirection index direction) in			
			if isValidIndex nextIndex field then				
				if (get nextIndex field) == player then
					checkEnd' nextIndex (count+1) direction
				else
					count
			else count

instance Show Player where
	show p = 
		if p == Cross then "x"
		else if p == Circle then "o"
		else "-"
		
instance Show GameField where
	show field = concatWith "\n" (map (showRow field) [1..(height field)])
		where
			showRow field row = (foldl (\a b -> a++b) [] $ map show [(get (x,row) field)|x<-[1..(width field)]])
			concatWith separator items = (foldl (concatWith' separator) [] items)
			concatWith' separator a b =
				if a == [] then b
				else a++separator++b

{- Pomocne utility, ktere zatim nemaji zadne pouziti ve vyslednem programu: -}
						
gameFieldFromList :: GameField -> [Player] -> GameField
gameFieldFromList field x = convert field x (1,1)
	where
		convert field [] _ = field
		convert field (x:xs) index = 
			convert (push index x field) xs (moveIndex field index)
		moveIndex field (x,y) = 
			if x == (width field) then 
				if y<(height field) then (1, y+1)
				else error "Spatny format."
			else (x+1, y)

instance Read Player where
	readsPrec _ s = read' s
		where
			read' :: String -> [(Player, String)]
			read' ('-':x) = [(None,x)]
			read' ('x':x) = [(Cross,x)]
			read' ('o':x) = [(Circle,x)]

	
{- ------------------------------- Minimax ---------------------------------- -}
{- -------------------------------------------------------------------------- -}
{- -------------------------------------------------------------------------- -}

{-
Vyhodnoti vyhodnost dane herni situace pro daneho hrace.
Funguje tak, ze zapocita kladne resp. zaporne body za kazdou souvislou radu 
hrace resp. jeho protihrace. Rady ktere jsou na obou koncich "volne" dostavaji 
vyrazne vetsi skore.
-}
evaluate:: Player -> GameField -> Int
evaluate player field = sum $
	(map (eval (0,1)) [(x,1)|x<-[1..(width field)]]) ++		-- zacatky na hornim radku, smer kolmo dolu
	(map (eval (1,0)) [(1,y)|y<-[1..(height field)]]) ++		-- zacatky v prvnim sloupci, smer doprava
	(map (eval (1,1)) [(x,1)|x<-[1..(width field)]]) ++		-- zacatky na hornim radku, smer sikmo doprava dolu
	(map (eval (1,1)) [(1,y)|y<-[1..(height field)]]) ++		-- zacatky v prvnim sloupci, smer sikmo doprava dolu
	(map (eval (-1,1)) [(x,1)|x<-[1..(width field)]]) ++		-- zacatky na hornim radku, smer sikmo doleva dolu
	(map (eval (-1,1)) [(1,y)|y<-[1..(height field)]])		-- zacatky v prvnim sloupci, smer sikmo doprava dolu	
	where	
		eval direction index =
			eval' direction 0 False 0 index player evalMyLine +
			eval' direction 0 False 0 index (switchPlayer player) evalEnemyLine

		eval' direction countInLine wasFree acc index player evalLineFunc =
			let nextIndex = (moveInDirection index direction) in
			if isValidIndex nextIndex field then
				if (get index field) == player then
					eval' direction (countInLine+1) wasFree acc nextIndex player evalLineFunc
				else
					-- pokud zde hracova line nepokracuje vratim vyhodnoceni dosavadni line
					-- a pokracuji dal
					let isFree = ((get index field) == None) in
					let currentLineScore = evalLineFunc wasFree isFree countInLine in
					eval' direction 0 isFree (currentLineScore+acc) nextIndex player evalLineFunc
			else
				-- jsem na konci hraciho planu, takze z teto strany urcite neni free
				acc + (evalLineFunc wasFree False countInLine)
				
		evalMyLine free1 free2 length =
			if length > 1 then
				if free1 && free2 then
					if length == 3 then 100
					else if length > 3 then 7000
					else 5
				else if free1 || free2 then length
				else 0
			else 0

		evalEnemyLine free1 free2 length = 
			if length > 1 then
				if free1 && free2 then
					if length == 3 then -200
					else if length > 3 then -12000
					else -20
				else if free1 || free2 then -length*2
				else 0
			else 0

{- Datovy typ LineInfo nese informaci o rade - jeji delku a zda je na jejich koncich volne hraci policko -}
data LineInfo = LineInfo { lineLength::Int, free1, free2::Bool, player::Player } deriving Show

freeBoth :: LineInfo -> Bool
freeBoth lineInfo = (free1 lineInfo && free2 lineInfo)

freeOne :: LineInfo -> Bool
freeOne lineInfo = (free1 lineInfo || free2 lineInfo)

{- 
Vrati seznam vsech rad ve vsech smerech od zadaneho bodu.
Dve rady, ktere jsou proti sobe (napr. smer (1,1) a (-1,-1)) jsou za sebou.
Prvni polovina jsou rady playera, druha jsou rady protivnika.
Pouziva se pri heuristice.
-}
getLinesInfo :: (Int, Int) -> GameField -> Player -> [(LineInfo,LineInfo)]
getLinesInfo pos field player = 	
	let isFirstCellFree = (get pos field) == None in
	-- pro kazdou dvojici protilehlych smeru hrac zavolam getLineInfo'
	map (getLinesInfo' isFirstCellFree) allDirectionsInZip
	where
		getLinesInfo' isFirstCellFree (direction1, direction2) = 
			(getLineInfoInDirection pos 0 isFirstCellFree direction1,
			 getLineInfoInDirection pos 0 isFirstCellFree direction2)
		-- postupuje v zadanem smeru, pokud narazi na konec, volne misto nebo protihrace, vrati vysledek
		getLineInfoInDirection pos length isFirstCellFree direction = 
			let newPos = moveInDirection pos direction in
			if not $ isValidIndex newPos field then
				LineInfo length isFirstCellFree False player
			else
				let currentCell = get newPos field in				
				if currentCell == None then 
					LineInfo length isFirstCellFree True player
				else if currentCell == player then 
					getLineInfoInDirection newPos (length+1) isFirstCellFree direction
				else 
					LineInfo length isFirstCellFree False player


{- 
Utridi seznam tahu, podle vyhodnosti.
Vraci i vysledek heuristiky, ktery muze byt pouzit pro ztratove orezani.
-}
heuristic :: GameField -> Player -> [(Int, Int)] -> [((Int, Int), Int)]
heuristic field player plays = 
	-- dvojice pozice a score setridim podle skore, vzestupne proto jsou argumenty compare prohozeny
	(sortBy (\(_,score) (_, score2) -> compare score2 score)
	(map (\pos -> (pos, getScore pos)) plays))
	where
		getScore pos = 
			let myLines = getLinesInfo pos field player in
			let enemyLines = getLinesInfo pos field (switchPlayer player) in
			let specialScore = getSpecialScore myLines in
			let enemySpecialScore = getSpecialScore enemyLines in
			if specialScore > 0 then specialScore
			else if enemySpecialScore > 0 then enemySpecialScore - 25
			else (getScore' myLines) + (getScore' enemyLines)

		getScore' lines = 
			sum $ map getLineScore lines 

		getLineScore (line1, line2) =
			let lengthSum = lineLength line1 + lineLength line2 in
			if freeBoth line1 && freeBoth line2 then lengthSum*3
			else if freeBoth line1 || freeBoth line2 then  lengthSum
			else 1

		getSpecialScore lines = 
			specialScore4InLine lines

		filterNInLine n lines =
			filter (\(line1, line2) -> (lineLength line1 + lineLength line2) >= n) lines

		filterNInLineOneFree n lines =
			filter (\(line1,line2) -> freeBoth line2 || freeBoth line2) $ filterNInLine n lines

		filterNInLineBothFree n lines =
			filter (\(line1,line2) -> freeBoth line2 && freeBoth line2) $ filterNInLine n lines

		-- vysledkem bude petice
		specialScore4InLine lines = 
			if (length $ filterNInLine 4 lines) > 0 then 200
			else specialScore3InLineFree lines

		-- vysledkem bude ctverice volna z obou stran
		specialScore3InLineFree lines = 
			if (length $ filterNInLineBothFree 3 lines) > 0 then 175
			else specialScore3InLineCross lines

		-- vysledkem budou 2 ctverice, kazda volna z jedne strany
		specialScore3InLineCross lines =
			if (length $ filterNInLineOneFree 3 lines) >= 2 then 150
			else specialScore2InLineCross lines

		-- vysledkem budou minimalne dve trojice volne z obou stran
		specialScore2InLineCross lines =
			if (length $ filterNInLineBothFree 2 lines) >= 2 then 125
			else 0

{- pomocna funkce pro ladici vypisy -}
-- dump category x y = y
-- dump 0 x y = trace x y
-- dump 1 x y = trace x y
dump _ x y = y

{- konstanty pro minimalni a max. mozne skore pri ohodnoceni v minimaxu na dne rekurze -}
maximalScore = 16000
minimalScore = -16000

{- samotny algoritmus minimax -}
minimax :: Player -> GameField -> (Int, Int)
minimax player field = 
	let (pos, _) = (minimax' player player 0 field maximalScore []) in pos
	where		
		-- pattern pro dno rekurze, pouze spocita vysledne skore
		minimax' currentPlayer startPlayer 5 field _ playsStack = 
			-- ohodnotim vyhodnost pro aktualniho hrace
			let score = evaluate currentPlayer field in		
			-- v pripade, ze je na tahu protihrac vysledek zneguji
			if currentPlayer == startPlayer then 
				dump 0 ("dno rekurze pro tahy " ++ concat (map show (reverse playsStack)) ++ 
				", score: " ++ show score) $ 
				((0,0), score)
			else 
				dump 0 ("dno rekurze pro tahy " ++ concat (map show (reverse playsStack)) ++ 
				", score: " ++ show (-score)) $ 
				((0,0), -score)

		-- pattern pro dalsi hladinu rekurze
		minimax' currentPlayer startPlayer deepth field previousBestScore playsStack = 				
			let playAndField = 
				-- ze vsech moznych tahu (serazenych heuristikou viz telo getPlayPositions)
				-- si utvorim si dvojice tah a hraci pole, ktere po takovem tahu vznikne
				(map (\pos -> (pos,push pos currentPlayer field)) (getPlayPositions field deepth player)) in		
			let endOfGamePlays = 
				-- podivam se, jestli tam nekde neni konec hry pro aktualniho hrace vitezny
				(filter (\(a,b) -> (checkEndOfGame a currentPlayer b)) playAndField) in

			dump 3 ("Hloubka: " ++ show deepth ++ ", pocet tahu: " ++ show (length playAndField) ++ 
			", konec hry: " ++ show (length endOfGamePlays > 0)) $
			dump 3 ("pozice " ++ show (map fst playAndField)) $
			-- pokud tam opravdu takovy je, ukoncim tuto vetev vypoctu
			if (length endOfGamePlays) > 0 then 
				-- podle hrace urcim score
				if currentPlayer == startPlayer then (fst $ head endOfGamePlays, maximalScore)
				else (fst $ head endOfGamePlays, minimalScore)
			-- pokud tam neni koncovy tah, ponorim se do rekurze
			else
				minimaxBody currentPlayer startPlayer deepth playAndField previousBestScore playsStack
		
		-- Hlavni telo minimaxu, prochazi vsechny mozne tahy v dane hloubce a spousti rekurzi
		-- pritom hlida moznost alfa-beta rezu
		minimaxBody currentPlayer startPlayer deepth playAndField previousBestScore playsStack = 
			let firstPlay = (fst (head playAndField)) in
			let initialScore = getWorstScoreFor currentPlayer startPlayer in
			minimaxBody' currentPlayer startPlayer deepth previousBestScore playsStack playAndField firstPlay initialScore
		
		minimaxBody' _ _ deepth _ _ [] result score = 
			dump 3 ("na hladine " ++ show deepth ++ " vybrana pos " ++ show result ++ ", score " ++ show score) $
			(result, score)

		minimaxBody' currentPlayer startPlayer deepth 
			previousBestScore playsStack ((play,field):xs) resultAccumulator resultScoreAccumulator =
			let enemy = switchPlayer currentPlayer in
			let (_,currentResult) = 
				minimax' enemy startPlayer (deepth+1) field resultScoreAccumulator (play:playsStack) in
			let recursiveCall = minimaxBody' currentPlayer startPlayer deepth previousBestScore playsStack xs in
			if currentPlayer == startPlayer then
				if currentResult > resultScoreAccumulator then 
					if currentResult >= previousBestScore then (play, currentResult) -- alfa-beta rez
					else recursiveCall play currentResult 
				else recursiveCall resultAccumulator resultScoreAccumulator 
			else
				if currentResult < resultScoreAccumulator then 
					if currentResult <= previousBestScore then (play, currentResult) -- alfa-beta rez
					else recursiveCall play currentResult
				else recursiveCall resultAccumulator resultScoreAccumulator
		
		-- vrati vsechny hratelne pozice serazene podle heuristiky a ztratove orezane
		getPlayPositions field deepth player = 
			let plays = getAllPlayPositionsWithScore field player in
			let filtered = filter (\(_, score) -> (score >= (10+deepth*2))) plays in
			dump 1 ("hladina " ++ show deepth ++ " #filtered " ++ show (length filtered)) $
			map (\(pos,score) -> pos) $			
			if length filtered > 0 then filtered
			else 
				let filtered2 = filter (\(_,score) -> (score >= 7)) plays in
				dump 1 ("#filtered2 " ++ show (length filtered2)) $
				if length filtered2 > 0 then take 3 $ filtered2
				else take howManyToTake plays
			where
				howManyToTake = 
					if deepth <= 1 then 2
					else 1
		
		-- vrati vsechny hratelne pozice se skore od heuristiky
		getAllPlayPositionsWithScore field player = heuristic field player $ getAllPlayPositions field

		-- vrati vsechny hratelne pozice
		getAllPlayPositions field = 					
			let b = border field in
			let (btop, bbottom, bleft, bright) = (top b, bottom b, left b, right b) in
			filter (\index -> (isValidIndex index field) && (get index field == None)) 
				[(x,y) | x<-[(bleft-1)..(bright+1)], y<-[(btop-1)..(bbottom+1)]]
				
		-- pomocna metoda pro inicializaci skore
		getWorstScoreFor currentPlayer startPlayer =
			if currentPlayer == startPlayer then minimalScore
			else maximalScore						
	
{- ------------------------- Uzivatelske rozhrani --------------------------- -}
{- -------------------------------------------------------------------------- -}
{- -------------------------------------------------------------------------- -}

data GamePlayer = GamePlayer {play::(GameField->(IO (Int, Int))), symbol::Player}

checkEndOfGameAfterPlay :: GameField -> Player -> (Int, Int) -> IO (Bool)
checkEndOfGameAfterPlay gameField playerSymbol (-1, -1) = do return True
checkEndOfGameAfterPlay gameField playerSymbol pos =
	if checkEndOfGame pos playerSymbol gameField then 
		do
		clearScreen
		setCursorPosition 0 0
		putStrLn (show gameField)
		putStrLn ("Konec hry. Vitezem je " ++ show playerSymbol)
		return True
	else if isFull gameField then
		do
		clearScreen
		setCursorPosition 0 0
		putStrLn (show gameField)
		putStrLn "Konec hry. Remiza!"
		return True
	else
		do
		return False

game gameField player1 player2 endOfGame = 
	if endOfGame then do return ()
	else
		do
		--c <- getChar -- pro debugovani, aby bylo videt trace resp. dump... -}
		clearScreen
		setCursorPosition 0 0
		putStrLn (show gameField)		
		putStrLn "Ovladani: "
		putStrLn "  pohyb: w, s, a, d"
		putStrLn "  zahrat na aktualni pozici: mezernik"
		putStrLn "  konec hry: k"
		pos <- (play player1) gameField				
		endOfGame <- checkEndOfGameAfterPlay (updateField' pos player1 gameField) (symbol player1) pos
		game (updateField' pos player1 gameField) player2 player1 endOfGame
	where
		updateField' (-1, -1) _ field = field
		updateField' pos player field = push pos (symbol player) field

userPlay gameField = do	
	userPlay' 0 0 gameField
	where
		userPlay' x y gameField = do
			setCursorPosition y x
			c <- getChar
			case c of
				'w' -> 	if y > 0 then userPlay' x (y-1) gameField
					else userPlay' x y gameField

				's' -> 	if y < ((height gameField)-1) then userPlay' x (y+1) gameField
					else userPlay' x y gameField

				'a' -> 	if x > 0 then userPlay' (x-1) y gameField
					else userPlay' x y gameField

				'd' ->	if x < ((width gameField)-1) then userPlay' (x+1) y gameField
					else userPlay' x y gameField

				'k' -> return (-1, -1)	-- tato pozice indikuje konec hry

				' ' ->  if (get (x+1,y+1) gameField) == None then
						return (x+1,y+1)	-- hrac chce na aktualni policko zahrat, a tak vratim jeho polohu
					else
						userPlay' x y gameField

				_   -> userPlay' x y gameField

computerPlay playerSymbol gameField = do 
	return (minimax playerSymbol gameField)

readChar allowedChars = do
	c <- getChar
	check c allowedChars
	where
		check c allowedChars = 
			if c `elem` allowedChars then do return c
			else do readChar allowedChars

choosePlayers = do	
	putStr "\nNejprve vyber svuj symbol: 1. kolecko, 2. krizek - "
	symbol <- readChar ['1', '2']
	putStr "\nDruhy hrac bude: 1. pocitac, 2. hrac na stejnem pocitaci - "
	ai <- readChar ['1', '2']
	putStr "\nKdo bude zacinat hru: 1. uzivatel, 2. protihrac - "
	startPlayerCh <- readChar ['1', '2']	
	putStrLn ""
	players <- (createPlayers symbol ai)
	orderPlayers startPlayerCh players
	where
		orderPlayers '1' (user, computer) = do return (user, computer)
		orderPlayers '2' (user, computer) = do return (computer, user)
		createPlayers symbolCh '2' = do
			return (GamePlayer userPlay (symbolChToPlayerSymbol symbolCh), 
				GamePlayer userPlay (switchPlayer $ symbolChToPlayerSymbol symbolCh))
		createPlayers symbolCh _ = do			
			return (GamePlayer userPlay (symbolChToPlayerSymbol symbolCh), createComputerPlayer symbolCh)
		symbolChToPlayerSymbol c =
			if c == '1' then Circle
			else Cross
		createComputerPlayer symbolCh =
			let computerSymbol = switchPlayer (symbolChToPlayerSymbol symbolCh) in
			GamePlayer (computerPlay computerSymbol) computerSymbol	

readInt = do
	readInt' 0 
	where
		readInt' num = do
			c <- readChar ['0','1','2','3','4','5','6','7','8','9', '\n']
			processInput num c
		processInput num '\n' = do
			return num
		processInput num c = do
			readInt' (num*10 + (read [c]))
	
chooseGameFieldSize = do
	putStrLn "Zadej velikost hraciho pole: "
	putStr "sirka: "
	width <- readInt
	putStr "vyska: "
	height <- readInt
	validate (width, height)
	where
		validate (width, height) =
			if width > 70 || height > 17 || width < 5 || height < 5 then 
				do 
				putStrLn "Zadej prosim rozumne rozmery. (sirka od 5 do 70, vyska od 5 do 17)"
				chooseGameFieldSize
			else do return (width, height)

main = do
	clearScreen
	setCursorPosition 0 0
	putStrLn "Vitej ve hre piskvorky."
	putStrLn "Pokud chces preskocit nastaveni hry a rovnou hrat stiskni enter."
	putStrLn "Pokud chces nastavit rozmery hraciho pole, kdo bude zacinat a dalsi stiskni mezernik."
	c <- readChar ['\n', ' ']
	(player1, player2, width, height) <- settings c
	hSetEcho stdin False 
	hSetBuffering stdin NoBuffering 
	hSetBuffering stdout NoBuffering	
	game (createGameField width height) player1 player2 False
	hSetEcho stdin True
	where
		settings '\n' = do
			return (GamePlayer userPlay Cross, GamePlayer (computerPlay Circle) Circle, 10, 10)
		settings _ = do
			(player1, player2) <- choosePlayers
			(width, height) <- chooseGameFieldSize
			return (player1, player2, width, height)

